home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / Convert / ASN1.pm next >
Encoding:
Perl POD Document  |  2008-09-15  |  9.3 KB  |  445 lines
  1. # Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4.  
  5. package Convert::ASN1;
  6.  
  7. # $Id: ASN1.pm,v 1.29 2003/10/08 14:29:17 gbarr Exp $
  8.  
  9. use 5.004;
  10. use strict;
  11. use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @opParts @opName $AUTOLOAD);
  12. use Exporter;
  13.  
  14. use constant CHECK_UTF8 => $] > 5.007;
  15.  
  16. BEGIN {
  17.   local $SIG{__DIE__};
  18.   eval { require bytes and 'bytes'->import };
  19.  
  20.   if (CHECK_UTF8) {
  21.     require Encode;
  22.     require utf8;
  23.   }
  24.  
  25.   @ISA = qw(Exporter);
  26.   $VERSION = "0.22";
  27.  
  28.   %EXPORT_TAGS = (
  29.     io    => [qw(asn_recv asn_send asn_read asn_write asn_get asn_ready)],
  30.  
  31.     debug => [qw(asn_dump asn_hexdump)],
  32.  
  33.     const => [qw(ASN_BOOLEAN     ASN_INTEGER      ASN_BIT_STR      ASN_OCTET_STR
  34.          ASN_NULL        ASN_OBJECT_ID    ASN_REAL         ASN_ENUMERATED
  35.          ASN_SEQUENCE    ASN_SET          ASN_PRINT_STR    ASN_IA5_STR
  36.          ASN_UTC_TIME    ASN_GENERAL_TIME ASN_RELATIVE_OID
  37.          ASN_UNIVERSAL   ASN_APPLICATION  ASN_CONTEXT      ASN_PRIVATE
  38.          ASN_PRIMITIVE   ASN_CONSTRUCTOR  ASN_LONG_LEN     ASN_EXTENSION_ID ASN_BIT)],
  39.  
  40.     tag   => [qw(asn_tag asn_decode_tag2 asn_decode_tag asn_encode_tag asn_decode_length asn_encode_length)]
  41.   );
  42.  
  43.   @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
  44.   $EXPORT_TAGS{all} = \@EXPORT_OK;
  45.  
  46.   @opParts = qw(
  47.     cTAG cTYPE cVAR cLOOP cOPT cCHILD cDEFINE
  48.   );
  49.  
  50.   @opName = qw(
  51.     opUNKNOWN opBOOLEAN opINTEGER opBITSTR opSTRING opNULL opOBJID opREAL
  52.     opSEQUENCE opSET opUTIME opGTIME opUTF8 opANY opCHOICE opROID opBCD
  53.   );
  54.  
  55.   foreach my $l (\@opParts, \@opName) {
  56.     my $i = 0;
  57.     foreach my $name (@$l) {
  58.       my $j = $i++;
  59.       no strict 'refs';
  60.       *{__PACKAGE__ . '::' . $name} = sub () { $j }
  61.     }
  62.   }
  63. }
  64.  
  65. sub _internal_syms {
  66.   my $pkg = caller;
  67.   no strict 'refs';
  68.   for my $sub (@opParts,@opName,'dump_op') {
  69.     *{$pkg . '::' . $sub} = \&{__PACKAGE__ . '::' . $sub};
  70.   }
  71. }
  72.  
  73. sub ASN_BOOLEAN     () { 0x01 }
  74. sub ASN_INTEGER     () { 0x02 }
  75. sub ASN_BIT_STR     () { 0x03 }
  76. sub ASN_OCTET_STR     () { 0x04 }
  77. sub ASN_NULL         () { 0x05 }
  78. sub ASN_OBJECT_ID     () { 0x06 }
  79. sub ASN_REAL         () { 0x09 }
  80. sub ASN_ENUMERATED    () { 0x0A }
  81. sub ASN_RELATIVE_OID    () { 0x0D }
  82. sub ASN_SEQUENCE     () { 0x10 }
  83. sub ASN_SET         () { 0x11 }
  84. sub ASN_PRINT_STR    () { 0x13 }
  85. sub ASN_IA5_STR        () { 0x16 }
  86. sub ASN_UTC_TIME    () { 0x17 }
  87. sub ASN_GENERAL_TIME    () { 0x18 }
  88.  
  89. sub ASN_UNIVERSAL     () { 0x00 }
  90. sub ASN_APPLICATION     () { 0x40 }
  91. sub ASN_CONTEXT     () { 0x80 }
  92. sub ASN_PRIVATE        () { 0xC0 }
  93.  
  94. sub ASN_PRIMITIVE    () { 0x00 }
  95. sub ASN_CONSTRUCTOR    () { 0x20 }
  96.  
  97. sub ASN_LONG_LEN    () { 0x80 }
  98. sub ASN_EXTENSION_ID    () { 0x1F }
  99. sub ASN_BIT         () { 0x80 }
  100.  
  101.  
  102. sub new {
  103.   my $pkg = shift;
  104.   my $self = bless {}, $pkg;
  105.  
  106.   $self->configure(@_);
  107.   $self;
  108. }
  109.  
  110.  
  111. sub configure {
  112.   my $self = shift;
  113.   my %opt = @_;
  114.  
  115.   $self->{options}{encoding} = uc($opt{encoding} || 'BER');
  116.  
  117.   unless ($self->{options}{encoding} =~ /^[BD]ER$/) {
  118.     require Carp;
  119.     Carp::croak("Unsupported encoding format '$opt{encoding}'");
  120.   }
  121.  
  122.   for my $type (qw(encode decode)) {
  123.     if (exists $opt{$type}) {
  124.       while(my($what,$value) = each %{$opt{$type}}) {
  125.     $self->{options}{"${type}_${what}"} = $value;
  126.       }
  127.     }
  128.   }
  129. }
  130.  
  131.  
  132.  
  133. sub find {
  134.   my $self = shift;
  135.   my $what = shift;
  136.   return unless exists $self->{tree}{$what};
  137.   my %new = %$self;
  138.   $new{script} = $new{tree}->{$what};
  139.   bless \%new, ref($self);
  140. }
  141.  
  142.  
  143. sub prepare {
  144.   my $self = shift;
  145.   my $asn  = shift;
  146.  
  147.   $self = $self->new unless ref($self);
  148.   my $tree;
  149.   if( ref($asn) eq 'GLOB' ){
  150.     local $/ = undef;
  151.     my $txt = <$asn>;
  152.     $tree = Convert::ASN1::parser::parse($txt);
  153.   } else {
  154.     $tree = Convert::ASN1::parser::parse($asn);
  155.   }
  156.  
  157.   unless ($tree) {
  158.     $self->{error} = $@;
  159.     return;
  160.     ### If $self has been set to a new object, not returning
  161.     ### this object here will destroy the object, so the caller
  162.     ### won't be able to get at the error.
  163.   }
  164.  
  165.   $self->{tree} = _pack_struct($tree);
  166.   $self->{script} = (values %$tree)[0];
  167.   $self;
  168. }
  169.  
  170. sub prepare_file {
  171.   my $self = shift;
  172.   my $asnp = shift;
  173.  
  174.   local *ASN;
  175.   open( ASN, $asnp )
  176.       or do{ $self->{error} = $@; return; };
  177.   my $ret = $self->prepare( \*ASN );
  178.   close( ASN );
  179.   $ret;
  180. }
  181.  
  182. sub registeroid {
  183.   my $self = shift;
  184.   my $oid  = shift;
  185.   my $handler = shift;
  186.  
  187.   $self->{options}{oidtable}{$oid}=$handler;
  188.   $self->{oidtable}{$oid}=$handler;
  189. }
  190.  
  191. sub registertype {
  192.    my $self = shift;
  193.    my $def = shift;
  194.    my $type = shift;
  195.    my $handler = shift;
  196.  
  197.    $self->{options}{handlers}{$def}{$type}=$handler;
  198. }
  199.  
  200. # In XS the will convert the tree between perl and C structs
  201.  
  202. sub _pack_struct { $_[0] }
  203. sub _unpack_struct { $_[0] }
  204.  
  205. ##
  206. ## Encoding
  207. ##
  208.  
  209. sub encode {
  210.   my $self  = shift;
  211.   my $stash = @_ == 1 ? shift : { @_ };
  212.   my $buf = '';
  213.   local $SIG{__DIE__};
  214.   eval { _encode($self->{options}, $self->{script}, $stash, [], $buf) }
  215.     or do { $self->{error} = $@; undef }
  216. }
  217.  
  218.  
  219.  
  220. # Encode tag value for encoding.
  221. # We assume that the tag has been correctly generated with asn_tag()
  222.  
  223. sub asn_encode_tag {
  224.   $_[0] >> 8
  225.     ? $_[0] & 0x8000
  226.       ? $_[0] & 0x800000
  227.     ? pack("V",$_[0])
  228.     : substr(pack("V",$_[0]),0,3)
  229.       : pack("v", $_[0])
  230.     : chr($_[0]);
  231. }
  232.  
  233.  
  234. # Encode a length. If < 0x80 then encode as a byte. Otherwise encode
  235. # 0x80 | num_bytes followed by the bytes for the number. top end
  236. # bytes of all zeros are not encoded
  237.  
  238. sub asn_encode_length {
  239.  
  240.   if($_[0] >> 7) {
  241.     my $lenlen = &num_length;
  242.  
  243.     return pack("Ca*", $lenlen | 0x80,  substr(pack("N",$_[0]), -$lenlen));
  244.   }
  245.  
  246.   return pack("C", $_[0]);
  247. }
  248.  
  249.  
  250. ##
  251. ## Decoding
  252. ##
  253.  
  254. sub decode {
  255.   my $self  = shift;
  256.  
  257.   local $SIG{__DIE__};
  258.   my $ret = eval { 
  259.     my (%stash, $result);
  260.     my $script = $self->{script};
  261.     my $stash = (1 == @$script && !$self->{script}[0][cVAR]) ? \$result : ($result=\%stash);
  262.  
  263.     _decode(
  264.     $self->{options},
  265.     $script,
  266.     $stash,
  267.     0,
  268.     length $_[0], 
  269.     undef,
  270.     {},
  271.     $_[0]);
  272.  
  273.     $result;
  274.   };
  275.   if ($@) {
  276.     $self->{'error'} = $@;
  277.     return undef;
  278.   }
  279.   $ret;
  280. }
  281.  
  282.  
  283. sub asn_decode_length {
  284.   return unless length $_[0];
  285.  
  286.   my $len = ord substr($_[0],0,1);
  287.  
  288.   if($len & 0x80) {
  289.     $len &= 0x7f or return (1,-1);
  290.  
  291.     return if $len >= length $_[0];
  292.  
  293.     return (1+$len, unpack("N", "\0" x (4 - $len) . substr($_[0],1,$len)));
  294.   }
  295.   return (1, $len);
  296. }
  297.  
  298.  
  299. sub asn_decode_tag {
  300.   return unless length $_[0];
  301.  
  302.   my $tag = ord $_[0];
  303.   my $n = 1;
  304.  
  305.   if(($tag & 0x1f) == 0x1f) {
  306.     my $b;
  307.     do {
  308.       return if $n >= length $_[0];
  309.       $b = ord substr($_[0],$n,1);
  310.       $tag |= $b << (8 * $n++);
  311.     } while($b & 0x80);
  312.   }
  313.   ($n, $tag);
  314. }
  315.  
  316.  
  317. sub asn_decode_tag2 {
  318.   return unless length $_[0];
  319.  
  320.   my $tag = ord $_[0];
  321.   my $num = $tag & 0x1f;
  322.   my $len = 1;
  323.  
  324.   if($num == 0x1f) {
  325.     $num = 0;
  326.     my $b;
  327.     do {
  328.       return if $len >= length $_[0];
  329.       $b = ord substr($_[0],$len++,1);
  330.       $num = ($num << 7) + ($b & 0x7f);
  331.     } while($b & 0x80);
  332.   }
  333.   ($len, $tag, $num);
  334. }
  335.  
  336.  
  337. ##
  338. ## Utilities
  339. ##
  340.  
  341. # How many bytes are needed to encode a number 
  342.  
  343. sub num_length {
  344.   $_[0] >> 8
  345.     ? $_[0] >> 16
  346.       ? $_[0] >> 24
  347.     ? 4
  348.     : 3
  349.       : 2
  350.     : 1
  351. }
  352.  
  353. # Convert from a bigint to an octet string
  354.  
  355. sub i2osp {
  356.     my($num, $biclass) = @_;
  357.     eval "use $biclass";
  358.     $num = $biclass->new($num);
  359.     my $neg = $num < 0
  360.       and $num = abs($num+1);
  361.     my $base = $biclass->new(256);
  362.     my $result = '';
  363.     while($num != 0) {
  364.         my $r = $num % $base;
  365.         $num = ($num-$r) / $base;
  366.         $result .= chr($r);
  367.     }
  368.     $result ^= chr(255) x length($result) if $neg;
  369.     return scalar reverse $result;
  370. }
  371.  
  372. # Convert from an octet string to a bigint
  373.  
  374. sub os2ip {
  375.     my($os, $biclass) = @_;
  376.     eval "require $biclass";
  377.     my $base = $biclass->new(256);
  378.     my $result = $biclass->new(0);
  379.     my $neg = ord($os) >= 0x80
  380.       and $os ^= chr(255) x length($os);
  381.     for (unpack("C*",$os)) {
  382.       $result = ($result * $base) + $_;
  383.     }
  384.     return $neg ? ($result + 1) * -1 : $result;
  385. }
  386.  
  387. # Given a class and a tag, calculate an integer which when encoded
  388. # will become the tag. This means that the class bits are always
  389. # in the bottom byte, so are the tag bits if tag < 30. Otherwise
  390. # the tag is in the upper 3 bytes. The upper bytes are encoded
  391. # with bit8 representing that there is another byte. This
  392. # means the max tag we can do is 0x1fffff
  393.  
  394. sub asn_tag {
  395.   my($class,$value) = @_;
  396.  
  397.   die sprintf "Bad tag class 0x%x",$class
  398.     if $class & ~0xe0;
  399.  
  400.   unless ($value & ~0x1f or $value == 0x1f) {
  401.     return (($class & 0xe0) | $value);
  402.   }
  403.  
  404.   die sprintf "Tag value 0x%08x too big\n",$value
  405.     if $value & 0xffe00000;
  406.  
  407.   $class = ($class | 0x1f) & 0xff;
  408.  
  409.   my @t = ($value & 0x7f);
  410.   unshift @t, (0x80 | ($value & 0x7f)) while $value >>= 7;
  411.   unpack("V",pack("C4",$class,@t,0,0));
  412. }
  413.  
  414.  
  415. BEGIN {
  416.   # When we have XS &_encode will be defined by the XS code
  417.   # so will all the subs in these required packages 
  418.   unless (defined &_encode) {
  419.     require Convert::ASN1::_decode;
  420.     require Convert::ASN1::_encode;
  421.     require Convert::ASN1::IO;
  422.   }
  423.  
  424.   require Convert::ASN1::parser;
  425. }
  426.  
  427. sub AUTOLOAD {
  428.   require Convert::ASN1::Debug if $AUTOLOAD =~ /dump/;
  429.   goto &{$AUTOLOAD} if defined &{$AUTOLOAD};
  430.   require Carp;
  431.   my $pkg = ref($_[0]) || ($_[0] =~ /^[\w\d]+(?:::[\w\d]+)*$/)[0];
  432.   if ($pkg and UNIVERSAL::isa($pkg, __PACKAGE__)) { # guess it was a method call
  433.     $AUTOLOAD =~ s/.*:://;
  434.     Carp::croak(sprintf q{Can't locate object method "%s" via package "%s"},$AUTOLOAD,$pkg);
  435.   }
  436.   else {
  437.     Carp::croak(sprintf q{Undefined subroutine &%s called}, $AUTOLOAD);
  438.   }
  439. }
  440.  
  441. sub DESTROY {}
  442.  
  443. sub error { $_[0]->{error} }
  444. 1;
  445.